home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
top.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
22KB
|
616 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; top.lsp
;;;;
;;;; Top-level loop, break loop, and error handlers
;;;;
;;;; Revised on July 11, by Carl Hoffman.
(in-package 'lisp)
(export '(+ ++ +++ - * ** *** / // ///))
(export '(break warn))
(export '*break-on-warnings*)
(export '*break-enable*)
(in-package 'system)
(export '*break-readtable*)
(export '(vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go))
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
(defvar +)
(defvar ++)
(defvar +++)
(defvar -)
(defvar *)
(defvar **)
(defvar ***)
(defvar /)
(defvar //)
(defvar ///)
(defvar *eof* (cons nil nil))
(defvar *lisp-initialized* nil)
(defvar *quit-tag* (cons nil nil))
(defvar *quit-tags* nil)
(defvar *break-level* '())
(defvar *break-env* nil)
(defvar *ihs-base* 1)
(defvar *ihs-top* 1)
(defvar *current-ihs* 1)
(defvar *frs-base* 0)
(defvar *frs-top* 0)
(defvar *break-enable* t)
(defvar *break-message* "")
(defvar *break-on-warnings* nil)
(defvar *break-readtable* nil)
(defvar *break-hidden-functions* nil)
(defvar *break-hidden-packages* (list (find-package 'system)))
(defun top-level ()
(let ((+ nil) (++ nil) (+++ nil)
(- nil)
(* nil) (** nil) (*** nil)
(/ nil) (// nil) (/// nil))
(setq *lisp-initialized* t)
(catch *quit-tag* (when (probe-file "init.lsp") (load "init.lsp")))
(loop
(setq +++ ++ ++ + + -)
(format t "~%~a>"
(if (eq *package* (find-package 'user)) ""
(package-name *package*)))
(reset-stack-limits)
(when (catch *quit-tag*
(setq - (locally (declare (notinline read))
(read *standard-input* nil *eof*)))
(when (eq - *eof*) (bye))
(let ((values (multiple-value-list
(locally (declare (notinline eval)) (eval -)))))
(setq /// // // / / values *** ** ** * * (car /))
(fresh-line)
(dolist (val /)
(locally (declare (notinline prin1)) (prin1 val))
(terpri))
nil))
(terpri *error-output*)
(break-current)))))
(defun warn (format-string &rest args)
(let ((*print-level* 4)
(*print-length* 4)
(*print-case* :upcase))
(cond (*break-on-warnings*
(apply #'break format-string args))
(t (format *error-output* "~&Warning: ")
(let ((*indent-formatted-output* t))
(apply #'format *error-output* format-string args))
nil))))
(defun universal-error-handler
(error-name correctable function-name
continue-format-string error-format-string
&rest args &aux message)
(declare (ignore error-name))
(let ((*print-pretty* nil)
(*print-level* 4)
(*print-length* 4)
(*print-case* :upcase))
(terpri *error-output*)
(cond ((and correctable *break-enable*)
(format *error-output* "~&Correctable error: ")
(let ((*indent-formatted-output* t))
(apply 'format *error-output* error-format-string args))
(terpri *error-output*)
(setq message (apply 'format nil error-format-string args))
(if function-name
(format *error-output*
"Signalled by ~:@(~S~).~%" function-name)
(format *error-output*
"Signalled by an anonymous function.~%"))
(format *error-output* "~&If continued: ")
(let ((*indent-formatted-output* t))
(format *error-output* "~?~&" continue-format-string args))
)
(t
(format *error-output* "~&Error: ")
(let ((*indent-formatted-output* t))
(apply 'format *error-output* error-format-string args))
(terpri *error-output*)
(setq message (apply 'format nil error-format-string args))
(if function-name
(format *error-output*
"Error signalled by ~:@(~S~).~%" function-name)
(format *error-output*
"Error signalled by an anonymous function.~%")))))
(break-level message)
(unless correctable (throw *quit-tag* *quit-tag*)))
(defun break (&optional format-string &rest args &aux message)
(let ((*print-pretty* nil)
(*print-level* 4)
(*print-length* 4)
(*print-case* :upcase))
(terpri *error-output*)
(cond (format-string
(format *error-output* "~&Break: ")
(let ((*indent-formatted-output* t))
(apply 'format *error-output* format-string args))
(terpri *error-output*)
(setq message (apply 'format nil format-string args)))
(t (format *error-output* "~&Break.~%")
(setq message ""))))
(let ((*break-enable* t)) (break-level message))
nil)
(defun terminal-interrupt (correctablep)
(let ((*break-enable* t))
(if correctablep
(cerror "Console interrupt." "Continues execution.")
(error "Console interrupt -- cannot continue."))))
(defun break-level (*break-message*)
(let* ((*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
(*quit-tag* (cons nil nil))
(*break-level* (cons t *break-level*))
(*ihs-base* (1+ *ihs-top*))
(*ihs-top* (1- (ihs-top)))
(*current-ihs* *ihs-top*)
(*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
(*frs-top* (frs-top))
(*break-env* nil)
(be *break-enable*)
(*break-enable* nil)
;(*standard-input* *terminal-io*)
(*readtable* (or *break-readtable* *readtable*))
(*read-suppress* nil)
(+ +) (++ ++) (+++ +++)
(- -)
(* *) (** **) (*** ***)
(/ /) (// //) (/// ///)
)
(unless be
(simple-backtrace)
(break-quit (length (cdr *break-level*))))
(terpri *error-output*)
(set-current)
(loop
(setq +++ ++ ++ + + -)
(format *debug-io* "~%~a>~{~*>~}"
(if (eq *package* (find-package 'user)) ""
(package-name *package*))
*break-level*)
(when
(catch *quit-tag*
(setq - (locally (declare (notinline read))
(read *debug-io* nil *eof*)))
(when (eq - *eof*) (bye))
(let ((values
(multiple-value-list
(locally (declare (notinline break-call evalhook))
(cond ((keywordp -)
(when (or (eq - :r) (eq - :resume)) (return))
(break-call - nil))
((and (consp -) (keywordp (car -)))
(when (or (eq (car -) :r) (eq (car -) :resume))
(return))
(break-call (car -) (cdr -)))
(t (evalhook - nil nil *break-env*)))))))
(setq /// // // / / values *** ** ** * * (car /))
(fresh-line *debug-io*)
(dolist (val /)
(locally (declare (notinline prin1)) (prin1 val *debug-io*))
(terpri *debug-io*)))
nil)
(terpri *debug-io*)
(break-current)))))
(defun break-call (key args &aux (fun (get key 'break-command)))
(if fun
(evalhook (cons fun args) nil nil *break-env*)
(format *debug-io* "~&~S is undefined break command.~%" key)))
(defun break-quit (&optional (level 0)
&aux (current-level (length *break-level*)))
(when (and (>= level 0) (< level current-level))
(let ((x (nth (- current-level level 1) *quit-tags*)))
(throw (cdr x) (cdr x))))
(break-current))
(defun break-previous (&optional (offset 1))
(do ((i (1- *current-ihs*) (1- i)))
((or (< i *ihs-base*) (<= offset 0))
(set-env)
(break-current))
(when (ihs-visible i)
(setq *current-ihs* i)
(setq offset (1- offset)))))
(defun set-current ()
(do ((i *current-ihs* (1- i)))
((or (ihs-visible i) (<= i *ihs-base*))
(setq *current-ihs* i)
(set-env)
(format *debug-io* "Broken at ~:@(~S~).~:[ Type :H for Help.~;~]"
(ihs-fname *current-ihs*)
(cdr *break-level*)))))
(defun break-next (&optional (offset 1))
(do ((i *current-ihs* (1+ i)))
((or (> i *ihs-top*) (< offset 0))
(set-env)
(break-current))
(when (ihs-visible i)
(setq *current-ihs* i)
(setq offset (1- offset)))))
(defun break-go (ihs-index)
(setq *current-ihs* (min (max ihs-index *ihs-base*) *ihs-top*))
(if (ihs-visible *current-ihs*)
(progn (set-env) (break-current))
(break-previous)))
(defun break-message ()
(princ *break-message* *debug-io*)
(terpri *debug-io*)
(values))
(defun break-variables ()
(apply #'format *debug-io* "Local variables: ~#[none~;~S~;~S and ~S~
~:;~@{~#[~;and ~]~S~^, ~}~]."
(mapcar #'car (car *break-env*))))
(defun break-functions ()
(apply #'format *debug-io* "Local functions: ~#[none~;~S~;~S and ~S~
~:;~@{~#[~;and ~]~S~^, ~}~]."
(mapcar #'car (cadr *break-env*))))
(defun break-blocks ()
(apply #'format *debug-io* "Block names: ~#[none~;~S~;~S and ~S~
~:;~@{~#[~;and ~]~S~^, ~}~]."
(mapcan #'(lambda (x) (when (eq (cadr x) 'block) (list (car x))))
(caddr *break-env*))))
(defun break-tags ()
(apply #'format *debug-io* "Tags: ~#[none~;~S~;~S and ~S~
~:;~@{~#[~;and ~]~S~^, ~}~]."
(mapcan #'(lambda (x) (when (eq (cadr x) 'tag) (list (car x))))
(caddr *break-env*))))
(defun break-vs (&optional (x (ihs-vs *ihs-base*)) (y (ihs-vs *ihs-top*)))
(setq x (max x (ihs-vs *ihs-base*)))
(setq y (min y (1- (ihs-vs (1+ *ihs-top*)))))
(do ((ii *ihs-base* (1+ ii)))
((or (>= ii *ihs-top*) (>= (ihs-vs ii) x))
(do ((vi x (1+ vi)))
((> vi y) (values))
(do ()
((> (ihs-vs ii) vi))
(when (ihs-visible ii) (print-ihs ii))
(incf ii))
(format *debug-io* "~&VS[~d]: ~s" vi (vs vi))))))
(defun break-local (&optional (n 0) &aux (x (+ (ihs-vs *current-ihs*) n)))
(break-vs x x))
(defun break-bds (vars &aux (fi *frs-base*))
(unless (consp vars) (setq vars (list vars)))
(do ((bi (1+ (frs-bds (1- *frs-base*))) (1+ bi))
(last (frs-bds (1+ *frs-top*))))
((> bi last) (values))
(when (member (bds-var bi) vars)
(do ()
((or (> fi *frs-top*) (> (frs-bds fi) bi)))
(print-frs fi)
(incf fi))
(format *debug-io* "~&BDS[~d]: ~s = ~s"
bi (bds-var bi) (bds-val bi)))))
(defun simple-backtrace ()
(princ "Backtrace: " *debug-io*)
(do* ((i *ihs-base* (1+ i))
(b nil t))
((> i *ihs-top*) (terpri *debug-io*) (values))
(when (ihs-visible i)
(when b (princ " > " *debug-io*))
(write (ihs-fname i) :stream *debug-io* :escape t
:case (if (= i *current-ihs*) :upcase :downcase)))))
(defun backtrace (&optional (from *ihs-base*) (to *ihs-top*))
(setq from (max from *ihs-base*))
(setq to (min to *ihs-top*))
(do* ((i from (1+ i))
(j (or (sch-frs-base *frs-base* from) (1+ *frs-top*))))
((> i to) (values))
(when (ihs-visible i) (print-ihs i))
(do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
(print-frs j)
(incf j))))
(defun print-ihs (i &aux (*print-level* 2) (*print-length* 4))
(format t "~&~:[ ~;@ ~]IHS[~d]: ~s ---> VS[~d]"
(= i *current-ihs*)
i
(let ((fun (ihs-fun i)))
(cond ((or (symbolp fun) (compiled-function-p fun)) fun)
((consp fun)
(case (car fun)
(lambda fun)
(lambda-block (cdr fun))
(lambda-closure (cons 'lambda (cddddr fun)))
(lambda-block-closure (cddddr fun))
(t '(:zombi))))
(t :zombi)))
(ihs-vs i)))
(defun print-frs (i)
(format *debug-io* "~& FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]"
i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i)))
(defun frs-kind (i &aux x)
(case (frs-class i)
(:catch
(if (spicep (frs-tag i))
(or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
:key #'caddr :test #'eq))
(if (eq (cadar x) 'block)
`(block ,(caar x) ***)
`(tagbody ,@(reverse (mapcar #'car
(remove (frs-tag i) x
:test-not #'eq
:key #'caddr)))
***)))
`(block/tagbody ,(frs-tag i)))
`(catch ',(frs-tag i) ***)))
(:protect '(unwind-protect ***))
(t `(system-internal-catcher ,(frs-tag i)))))
(defun break-current ()
(if *break-level*
(format *debug-io* "Broken at ~:@(~S~)." (ihs-fname *current-ihs*))
(format *debug-io* "~&Top level."))
(values))
(defun break-hide (fname)
(unless (member fname *break-hidden-functions*)
(setq *break-hidden-functions*
(cons fname *break-hidden-functions*))
(unless (ihs-visible *current-ihs*)
(break-previous)))
(values))
(defun break-unhide (fname)
(setq *break-hidden-functions*
(list-delq fname *break-hidden-functions*))
(values))
(defun break-unhide-package (package)
(setq package (find-package package))
(setq *break-hidden-packages*
(list-delq package *break-hidden-packages*))
(values))
(defun break-unhide-all ()
(setq *break-hidden-functions* nil)
(setq *break-hidden-packages* nil)
(values))
(defun break-hide-package (package)
(setq package (find-package package))
(unless (member package *break-hidden-packages*)
(setq *break-hidden-packages*
(cons package *break-hidden-packages*))
(unless (ihs-visible *current-ihs*)
(break-previous)))
(values))
(defun ihs-visible (i)
(let ((fname (ihs-fname i)))
(or (eq fname 'eval)
(eq fname 'evalhook)
(and (not (member (symbol-package fname) *break-hidden-packages*))
(not (null fname))
(not (member fname *break-hidden-functions*))))))
(defun ihs-fname (ihs-index)
(let ((fun (ihs-fun ihs-index)))
(cond ((symbolp fun) fun)
((consp fun)
(case (car fun)
(lambda 'lambda)
(lambda-block (cadr fun))
(lambda-block-closure (nth 4 fun))
(lambda-closure 'lambda-closure)
(t :zombi)))
((compiled-function-p fun)
(compiled-function-name fun))
(t :zombi))))
(defun set-env ()
(setq *break-env*
(if (ihs-compiled-p *current-ihs*)
nil
(let ((i (ihs-vs *current-ihs*)))
(list (vs i) (vs (1+ i)) (vs (+ i 2)))))))
(defun ihs-compiled-p (ihs-index)
(let ((fun (ihs-fun ihs-index)))
(or (and (symbolp fun) (not (special-form-p fun)))
(compiled-function-p fun))))
(defun list-delq (x l)
(cond ((null l) nil)
((eq x (car l)) (cdr l))
(t (rplacd l (list-delq x (cdr l))))))
(defun super-go (i tag &aux x)
(when (and (>= i *frs-base*) (<= i *frs-top*) (spicep (frs-tag i)))
(if (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
:key #'caddr :test #'eq))
; Interpreted TAGBODY.
(when (and (eq (cadar x) 'tag)
(member tag (mapcar #'car (remove (frs-tag i) x
:test-not #'eq
:key #'caddr))))
(internal-super-go (frs-tag i) tag t))
; Maybe, compiled cross-closure TAGBODY.
; But, it may also be compiled cross-closure BLOCK, in which case
; SUPER-GO just RETURN-FROMs with zero values.
(internal-super-go (frs-tag i) tag nil)))
(format *debug-io* "~s is invalid tagbody identification for ~s." i tag))
(defun break-backward-search-stack (sym &aux string)
(setq string (string sym))
(do* ((ihs (1- *current-ihs*) (1- ihs))
(fname (ihs-fname ihs) (ihs-fname ihs)))
((< ihs *ihs-base*)
(format *debug-io* "Search for ~a failed.~%" string))
(when (and (ihs-visible ihs)
(search string (symbol-name fname) :test #'char-equal))
(break-go ihs)
(return))))
(defun break-forward-search-stack (sym &aux string)
(setq string (string sym))
(do* ((ihs (1+ *current-ihs*) (1+ ihs))
(fname (ihs-fname ihs) (ihs-fname ihs)))
((> ihs *ihs-top*)
(format *debug-io* "Search for ~a failed.~%" string))
(when (and (ihs-visible ihs)
(search string (symbol-name fname) :test #'char-equal))
(break-go ihs)
(return))))
(defun break-variables-values ()
(dolist (x (car *break-env*))
(format *debug-io* "~S: ~S~%" (first x) (second x))))
(putprop :b 'simple-backtrace 'break-command)
(putprop :backtrace 'simple-backtrace 'break-command)
(putprop :bds 'break-bds 'break-command)
(putprop :blocks 'break-blocks 'break-command)
(putprop :bs 'break-backward-search-stack 'break-command)
(putprop :c 'break-current 'break-command)
(putprop :current 'break-current 'break-command)
(putprop :fs 'break-forward-search-stack 'break-command)
(putprop :functions 'break-functions 'break-command)
(putprop :go 'break-go 'break-command)
(putprop :h 'break-help 'break-command)
(putprop :help 'break-help 'break-command)
(putprop :hd 'break-hide 'break-command)
(putprop :hdp 'break-hide-package 'break-command)
(putprop :hh 'break-help-help 'break-command)
(putprop :hide 'break-hide 'break-command)
(putprop :hide-package 'break-hide-package 'break-command)
(putprop :hs 'break-help-stack-funs 'break-command)
(putprop :ihs 'backtrace 'break-command)
(putprop :l 'break-local 'break-command)
(putprop :lb 'break-blocks 'break-command)
(putprop :lf 'break-functions 'break-command)
(putprop :local 'break-local 'break-command)
(putprop :lt 'break-tags 'break-command)
(putprop :lv 'break-variables 'break-command)
(putprop :m 'break-message 'break-command)
(putprop :n 'break-next 'break-command)
(putprop :next 'break-next 'break-command)
(putprop :p 'break-previous 'break-command)
(putprop :previous 'break-previous 'break-command)
(putprop :q 'break-quit 'break-command)
(putprop :quit 'break-quit 'break-command)
(putprop :s 'break-backward-search-stack 'break-command)
(putprop :tags 'break-tags 'break-command)
(putprop :uh 'break-unhide 'break-command)
(putprop :uha 'break-unhide-all 'break-command)
(putprop :uhp 'break-unhide-package 'break-command)
(putprop :unhide 'break-unhide 'break-command)
(putprop :unhide-package 'break-unhide-package 'break-command)
(putprop :v 'break-variables 'break-command)
(putprop :variable 'break-variables 'break-command)
(putprop :vs 'break-vs 'break-command)
(putprop :vv 'break-variables-values 'break-command)
(defun break-help ()
(format *debug-io* "
Break-loop Command Summary:
:p (Previous) :n (Next) :go (GO)
:m (Message) :c (Current)
:h (Help) :hh (Help Help) :hs (Help Stack functions)
:q (Quit) :r (Resume or Return)
:b (Backtrace) :l (Local value)
:vs (Value Stack) :bds (BinD Stack) :ihs (Invocation Hist. Stack)
:lv (Local Variables) :v (= :lv) :lf (Local Functions)
:lb (Blocks) :lt (Tags)
:hd (HiDE) :hdp (HiDe Packages)
:uha (UnHide All) :uh (UnHide) :uhp (UnHide Packages)
:bs (Backward Search) :s (= :bs) :fs (Forward Search)
:vv (Variables Values)
Type :HH for more details.
"))
(defun break-help-help ()
(format *debug-io* "
Break-loop Commands:
:p [i] Go to the i-th previous function. i defaults to 1.
:n [i] Go to the i-the next function. i defaults to 1.
:go i Go to the function at IHS[i].
:m Print the error message.
:c Show the current function.
:h Show the break command summary.
:hh Show this message.
:hs Show stack-accessing functions.
:q [i] Return to the level i break-level (or top-level if i = 0).
i defaults to 0.
:r Return to the caller of break-level.
:b Print simple backtrace.
:l [i] Print i-th local value.
:vs [from [to]] Show values in the stack between VS[from] to VS[to].
'from' defaults to 0 and 'to' defaults to positive infinity.
:bds var-list Show previous bindings of the variables. 'var-list' may be
a symbol or a list of symbols.
:ihs [from [to]] Print backtrace between IHS[from] to IHS[to].
'from' defaults to 0 and 'to' defaults to positive infinity.
:lv Show local variables.
:lf Show local functions.
:lb Show block names.
:lt Show tags.
:hd symbol Hide the function named by the specified symbol.
:hdp package Hide functions in the specified package.
:uha Unhide all functions.
:uh symbol Unhide the function named by the specified symbol.
:uhp package Unhide functions in the specified package.
"))
(defun break-help-stack-funs ()
(format *debug-io* "
Use the following functions to directly access KCL stacks.
(SI:VS i) Returns the i-th entity in VS.
(SI:IHS-VS i) Returns the VS index of the i-th entity in IHS.
(SI:IHS-FUN i) Returns the function of the i-th entity in IHS.
(SI:FRS-VS i) Returns the VS index of the i-th entity in FRS.
(SI:FRS-BDS i) Returns the BDS index of the i-th entity in FRS.
(SI:FRS-IHS i) Returns the IHS index of the i-th entity in FRS.
(SI:BDS-VAR i) Returns the symbol of the i-th entity in BDS.
(SI:BDS-VAL i) Returns the value of the i-th entity in BDS.
(SI:SUPER-GO i tag)
Jumps to the specified tag established by the TAGBODY frame at
FRS[i]. Both arguments are evaluated. If FRS[i] happens to be
a non-TAGBODY frame, then (THROW (SI:IHS-TAG i) (VALUES)) is
performed.
Note that these functions are named by external symbols in the SYSTEM
package. For the KCL stacks, refer to Appendix B of the KCL Report.
"))